home *** CD-ROM | disk | FTP | other *** search
/ BCI NET / BCI NET Dec 94.iso / archives / programming / languages / obrn-a_1.4_upd2.lha / oberon-a / source / oc / Compiler.mod next >
Encoding:
Text File  |  1994-09-08  |  61.2 KB  |  2,060 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: Compiler.mod $
  4.   Description: Recursive-descent parser
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 4.12.1.1 $
  8.       $Author: fjc $
  9.         $Date: 1994/09/08 18:18:32 $
  10.  
  11.   Copyright © 1990-1993, ETH Zuerich
  12.   Copyright © 1993-1994, Frank Copeland
  13.   This module forms part of the OC program
  14.   See OC.doc for conditions of use and distribution
  15.  
  16.   Log entries are at the end of the file.
  17.  
  18. ***************************************************************************)
  19.  
  20. MODULE Compiler;
  21.  
  22. (*
  23. ** $C= CaseChk       $I= IndexChk  $L= LongAdr   $N= NilChk
  24. ** $P- PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
  25. ** $V= OvflChk       $Z= ZeroVars
  26. *)
  27.  
  28. IMPORT
  29.   Str := Strings, IO := StdIO, Oberon, Files, OCG, OCS, OCT, OCC, OCI,
  30.   OCE, OCP, OCH, SYS := SYSTEM;
  31.  
  32.  
  33. (* --- Exported declarations -------------------------------------------- *)
  34.  
  35.  
  36. VAR
  37.   newSF * : BOOLEAN;
  38.   forceCode * : BOOLEAN;
  39.  
  40.  
  41. (* --- Local declarations ----------------------------------------------- *)
  42.  
  43.  
  44. CONST
  45.  
  46.   NofCases = 128; RecDescSize = 8; AdrSize = OCG.PtrSize;
  47.   ProcSize = OCG.ProcSize; PtrSize = OCG.PtrSize; ParOrg = 2 * AdrSize;
  48.   LParOrg = 3 * AdrSize; XParOrg = 3 * AdrSize; ProcVarSize = 32768;
  49.  
  50.   ModNameLen = 26; (* Max. module name length, imposed by AmigaDOS *)
  51.  
  52. (* Symbols *)
  53.  
  54.   null    = OCS.null;    times  = OCS.times;  slash     = OCS.slash;
  55.   div     = OCS.div;     mod    = OCS.mod;    and       = OCS.and;
  56.   plus    = OCS.plus;    minus  = OCS.minus;  or        = OCS.or;
  57.   eql     = OCS.eql;     neq    = OCS.neq;    lss       = OCS.lss;
  58.   leq     = OCS.leq;     gtr    = OCS.gtr;    geq       = OCS.geq;
  59.   in      = OCS.in;      is     = OCS.is;     arrow     = OCS.arrow;
  60.   period  = OCS.period;  comma  = OCS.comma;  colon     = OCS.colon;
  61.   upto    = OCS.upto;    rparen = OCS.rparen; rbrak     = OCS.rbrak;
  62.   rbrace  = OCS.rbrace;  of     = OCS.of;     then      = OCS.then;
  63.   do      = OCS.do;      to     = OCS.to;     lparen    = OCS.lparen;
  64.   lbrak   = OCS.lbrak;   lbrace = OCS.lbrace; not       = OCS.not;
  65.   becomes = OCS.becomes; number = OCS.number; nil       = OCS.nil;
  66.   string  = OCS.string;  ident  = OCS.ident;  semicolon = OCS.semicolon;
  67.   bar     = OCS.bar;     end    = OCS.end;    else      = OCS.else;
  68.   elsif   = OCS.elsif;   until  = OCS.until;  if        = OCS.if;
  69.   case    = OCS.case;    while  = OCS.while;  repeat    = OCS.repeat;
  70.   loop    = OCS.loop;    with   = OCS.with;   exit      = OCS.exit;
  71.   return  = OCS.return;  array  = OCS.array;  record    = OCS.record;
  72.   pointer = OCS.pointer; begin  = OCS.begin;  const     = OCS.const;
  73.   type    = OCS.type;    var    = OCS.var;    procedure = OCS.procedure;
  74.   import  = OCS.import;  module = OCS.module; eof       = OCS.eof;
  75.   cpointer = OCS.cpointer; bpointer = OCS.bpointer; libcall = OCS.libcall;
  76.   for = OCS.for; by = OCS.by;
  77.  
  78. (* object modes *)
  79.   Var = OCG.Var; VarR = OCG.VarR; Ind = OCG.Ind; IndR = OCG.IndR;
  80.   Con = OCG.Con; Reg = OCG.Reg; Fld = OCG.Fld; Typ = OCG.Typ;
  81.   LProc = OCG.LProc; XProc = OCG.XProc; SProc = OCG.SProc;
  82.   TProc = OCG.TProc; FProc = OCG.FProc; Mod = OCG.Mod; Abs = OCG.Abs;
  83.   VarArg = OCG.VarArg;
  84.  
  85. (* object modes for language extensions *)
  86.   LibCall = OCG.LibCall;
  87.  
  88. (* structure forms *)
  89.   Undef = OCT.Undef; Byte = OCT.Byte; Bool = OCT.Bool; Char = OCT.Char;
  90.   SInt = OCT.SInt; Int = OCT.Int; LInt = OCT.LInt; Real = OCT.Real;
  91.   LReal = OCT.LReal; BSet = OCT.BSet; WSet = OCT.WSet; Set = OCT.Set;
  92.   String = OCT.String; NilTyp = OCT.NilTyp; NoTyp = OCT.NoTyp;
  93.   PtrTyp = OCT.PtrTyp; CPtrTyp = OCT.CPtrTyp; BPtrTyp = OCT.BPtrTyp;
  94.   Pointer = OCT.Pointer; CPointer = OCT.CPointer; BPointer = OCT.BPointer;
  95.   ProcTyp = OCT.ProcTyp; Array = OCT.Array; DynArr = OCT.DynArr;
  96.   Record = OCT.Record;
  97.  
  98.   intSet    = {SInt, Int, LInt};
  99.   ptrSet    = {Pointer, CPointer, BPointer};
  100.   uptrSet   = {CPointer, BPointer};
  101.   labeltyps = {Char, SInt, Int, LInt};
  102.  
  103.   NumLoopLevels = 16; MaxLoopLevel = NumLoopLevels - 1;
  104.  
  105. VAR
  106.  
  107.   sym, procNo : INTEGER;
  108.   LoopLevel, ExitNo : INTEGER;
  109.   LoopExit : ARRAY NumLoopLevels OF INTEGER;
  110.  
  111. (* CONST mname = "Compiler"; *)
  112.  
  113. (* --- Procedure declarations ------------------------------------------- *)
  114.  
  115.  
  116. (*----------------------------------)-*)
  117. PROCEDURE^ Type (VAR typ : OCT.Struct);
  118. PROCEDURE^ Expression (VAR x : OCT.Item);
  119. PROCEDURE^ Block
  120.   (proc : OCT.Object; VAR dsize : LONGINT; VAR retList : INTEGER);
  121.  
  122. (*------------------------------------*)
  123. PROCEDURE CheckSym (s : INTEGER);
  124.  
  125. BEGIN (* CheckSym *)
  126.   IF sym = s THEN OCS.Get (sym) ELSE OCS.Mark (s) END
  127. END CheckSym;
  128.  
  129. (*------------------------------------*)
  130. PROCEDURE qualident (VAR x : OCT.Item; allocDesc : BOOLEAN);
  131.  
  132.   (* CONST pname = "qualident"; *)
  133.  
  134.   VAR mnolev : INTEGER; obj : OCT.Object; desc : OCT.Desc; b : BOOLEAN;
  135.  
  136. BEGIN (* qualident *)
  137.   (* OCG.TraceIn (mname, pname); *)
  138.   (* sym = ident *)
  139.   OCT.Find (obj, mnolev); IF obj = NIL THEN OCS.Mark (0) END; OCS.Get (sym);
  140.   IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
  141.     OCS.Get (sym); mnolev := SHORT (-obj.a0);
  142.     IF sym = ident THEN
  143.       OCT.FindImport (obj, obj); IF obj = NIL THEN OCS.Mark (0) END;
  144.       OCS.Get (sym)
  145.     ELSE
  146.       OCS.Mark (10); obj := NIL
  147.     END;
  148.   END;
  149.   x.lev := mnolev; x.obj := obj;
  150.   IF obj # NIL THEN
  151.     x.mode := obj.mode; x.typ := obj.typ; x.a0 := obj.a0;
  152.     x.a1 := obj.a1; x.a2 := obj.a2; x.symbol := obj.symbol;
  153.     x.rdOnly := (mnolev < 0) & (obj.visible = OCT.RdOnly);
  154.     (*
  155.     IF mnolev < 0 THEN
  156.       b := (obj.visible = OCT.RdOnly); x.rdOnly := b
  157.     ELSE x.rdOnly := FALSE
  158.     END;
  159.     *)
  160.     IF
  161.       allocDesc & (x.mode IN {Var, Ind}) & (x.typ # NIL)
  162.       & (x.typ.form = DynArr)
  163.     THEN
  164.       desc := OCT.AllocDesc (); desc.mode := Var; desc.lev := x.lev;
  165.       desc.a0 := x.a0; desc.a1 := 0; desc.a2 := 0; x.desc := desc
  166.     ELSE
  167.       x.desc := NIL
  168.     END
  169.   ELSE
  170.     x.mode := Var; x.typ := OCT.undftyp; x.a0 := 0; x.obj := NIL;
  171.     x.rdOnly := FALSE; x.desc := NIL
  172.   END
  173.   (* ;OCG.TraceOut (mname, pname); *)
  174. END qualident;
  175.  
  176. (*------------------------------------*)
  177. PROCEDURE ConstExpression (VAR x : OCT.Item);
  178.  
  179.   (* CONST pname = "ConstExpression"; *)
  180.  
  181.   CONST
  182.     ConstTypes = {Undef .. NilTyp, CPtrTyp, BPtrTyp, CPointer, BPointer};
  183.  
  184. BEGIN (* ConstExpression *)
  185.   (* OCG.TraceIn (mname, pname); *)
  186.   Expression (x);
  187.   IF (x.mode # Con) OR ~(x.typ.form IN ConstTypes) THEN
  188.     OCS.Mark (50); x.mode := Con; x.typ := OCT.inttyp; x.a0 := 1;
  189.   END;
  190.   (* ;OCG.TraceOut (mname, pname); *)
  191. END ConstExpression;
  192.  
  193. (*------------------------------------*)
  194. PROCEDURE NewStr (form : INTEGER) : OCT.Struct;
  195.  
  196.   (* CONST pname = "NewStr"; *)
  197.  
  198.   VAR typ : OCT.Struct;
  199.  
  200. BEGIN (* NewStr *)
  201.   (* OCG.TraceIn (mname, pname); *)
  202.   typ := OCT.AllocStruct ();
  203.   typ.form := form; typ.mno := 0; typ.size := 4; typ.ref := 0;
  204.   typ.BaseTyp := OCT.undftyp; typ.strobj := NIL; typ.link := NIL;
  205.   (* ;OCG.TraceOut (mname, pname); *)
  206.   RETURN typ
  207. END NewStr;
  208.  
  209. (*------------------------------------*)
  210. PROCEDURE CheckMark (VAR mk : SHORTINT; readOnly : BOOLEAN);
  211.  
  212.   (* CONST pname = "CheckMark"; *)
  213.  
  214. BEGIN (* CheckMark *)
  215.   (* OCG.TraceIn (mname, pname); *)
  216.   OCS.Get (sym);
  217.   IF sym = times THEN
  218.     IF OCC.level = 0 THEN mk := OCT.Exp
  219.     ELSE mk := OCT.NotExp; OCS.Mark (46)
  220.     END;
  221.     OCS.Get (sym)
  222.   ELSIF sym = minus THEN
  223.     IF (OCC.level = 0) & readOnly THEN mk := OCT.RdOnly
  224.     ELSE mk := OCT.NotExp; OCS.Mark (47)
  225.     END;
  226.     OCS.Get (sym)
  227.   ELSE
  228.     mk := OCT.NotExp
  229.   END
  230.   (* ;OCG.TraceOut (mname, pname); *)
  231. END CheckMark;
  232.  
  233. (*------------------------------------*)
  234. PROCEDURE CheckUndefPointerTypes ();
  235.  
  236.   (* CONST pname = "CheckUndefPointerTypes"; *)
  237.  
  238.   (*------------------------------------*)
  239.   PROCEDURE CheckObj (obj : OCT.Object);
  240.  
  241.   BEGIN (* CheckObj *)
  242.     IF obj # NIL THEN
  243.       IF obj.mode = Undef THEN OCS.Mark (48) END;
  244.       CheckObj (obj.left); CheckObj (obj.right)
  245.     END
  246.   END CheckObj;
  247.  
  248. BEGIN (* CheckUndefPointerTypes *)
  249.   (* OCG.TraceIn (mname, pname); *)
  250.   CheckObj (OCT.topScope.link)
  251.   (* ;OCG.TraceOut (mname, pname); *)
  252. END CheckUndefPointerTypes;
  253.  
  254. (*------------------------------------*)
  255. PROCEDURE CheckForwardProcs ();
  256.  
  257.   (* CONST pname = "CheckForwardProcs"; *)
  258.  
  259.   (*------------------------------------*)
  260.   PROCEDURE CheckObj ( obj : OCT.Object );
  261.  
  262.     (*------------------------------------*)
  263.     PROCEDURE CheckTyp ( typ : OCT.Struct );
  264.       VAR fld : OCT.Object;
  265.     BEGIN (* CheckTyp *)
  266.       IF (typ # NIL) & (typ.form = Record) THEN
  267.         fld := typ.link;
  268.         WHILE fld # NIL DO
  269.           IF (fld.mode = TProc) & (fld.a2 < 0) THEN OCS.Mark (129) END;
  270.           fld := fld.left
  271.         END
  272.       END
  273.     END CheckTyp;
  274.  
  275.   BEGIN (* CheckObj *)
  276.     IF obj # NIL THEN
  277.       IF obj.mode IN {XProc, LProc} THEN
  278.         IF obj.a2 < 0 THEN OCS.Mark (129) END
  279.       ELSIF obj.mode = Typ THEN
  280.         CheckTyp (obj.typ)
  281.       END;
  282.       CheckObj (obj.left); CheckObj (obj.right)
  283.     END
  284.   END CheckObj;
  285.  
  286. BEGIN (* CheckForwardProcs *)
  287.   (* OCG.TraceIn (mname, pname); *)
  288.   CheckObj (OCT.topScope.link)
  289.   (* ;OCG.TraceOut (mname, pname); *)
  290. END CheckForwardProcs;
  291.  
  292. (*------------------------------------*)
  293. PROCEDURE RecordType (VAR typ : OCT.Struct);
  294.  
  295.   (* CONST pname = "RecordType"; *)
  296.  
  297.   VAR
  298.     adr, size : LONGINT;
  299.     fld, fld0, fld1, fld2 : OCT.Object;
  300.     ftyp : OCT.Struct;
  301.     base : OCT.Item;
  302.  
  303. BEGIN (* RecordType *)
  304.   (* OCG.TraceIn (mname, pname); *)
  305.   typ := NewStr (Record); typ.BaseTyp := NIL; typ.n := 0; adr := 0;
  306.   IF sym = lparen THEN
  307.     OCS.Get (sym); (* record extension *)
  308.     IF sym = ident THEN
  309.       qualident (base, FALSE);
  310.       IF (base.mode = Typ) & (base.typ.form = Record) THEN
  311.         typ.BaseTyp := base.typ; typ.n := base.typ.n + 1;
  312.         adr := base.typ.size
  313.       ELSE
  314.         OCS.Mark (52)
  315.       END;
  316.     ELSE
  317.       OCS.Mark (10)
  318.     END;
  319.     CheckSym (rparen)
  320.   END;
  321.   OCT.OpenScope (0); fld := NIL; fld1 := OCT.AllocObj(); fld2 := NIL;
  322.   LOOP
  323.     (* OCG.TraceIn (mname, "LOOP1"); *)
  324.     IF sym = ident THEN
  325.       LOOP
  326.         (* OCG.TraceIn (mname, "LOOP2"); *)
  327.         IF sym = ident THEN
  328.           IF typ.BaseTyp # NIL THEN
  329.             OCT.FindField (typ.BaseTyp, fld0);
  330.             IF fld0 # NIL THEN OCS.Mark (1) END
  331.           END;
  332.           OCT.Insert (OCS.name, fld, Fld); CheckMark (fld.visible, TRUE);
  333.           IF (fld # fld2) & (fld.link = NIL) THEN
  334.             IF fld2 = NIL THEN fld1.link := fld; OCT.topScope.right := fld
  335.             ELSE fld2.link := fld
  336.             END;
  337.             fld2 := fld
  338.           END;
  339.         ELSE
  340.           OCS.Mark (10)
  341.         END;
  342.         IF sym = comma THEN
  343.           OCS.Get (sym)
  344.         ELSIF sym = ident THEN
  345.           OCS.Mark (19)
  346.         ELSE
  347.           (* ;OCG.TraceOut (mname, "LOOP2"); *)
  348.           EXIT
  349.         END;
  350.         (* ;OCG.TraceOut (mname, "LOOP2"); *)
  351.       END; (* LOOP *)
  352.       CheckSym (colon); Type (ftyp);
  353.       IF ftyp.form = DynArr THEN ftyp := OCT.undftyp; OCS.Mark (325) END;
  354.       size := ftyp.size;
  355.       IF size > 1 THEN
  356.         INC (adr, adr MOD 2); INC (size, size MOD 2) (* word align *)
  357.       END;
  358.       WHILE fld1.link # NIL DO
  359.         (* OCG.TraceIn (mname, "WHILE1"); *)
  360.         fld1 := fld1.link; fld1.typ := ftyp;
  361.         fld1.a0 := adr; INC (adr, size)
  362.         (* ;OCG.TraceOut (mname, "WHILE1"); *)
  363.       END;
  364.     END; (* IF *)
  365.     IF sym = semicolon THEN
  366.       OCS.Get (sym)
  367.     ELSIF sym = ident THEN
  368.       OCS.Mark (38)
  369.     ELSE
  370.       (* ;OCG.TraceOut (mname, "LOOP1"); *)
  371.       EXIT
  372.     END;
  373.     (* ;OCG.TraceOut (mname, "LOOP1"); *)
  374.   END; (* LOOP *)
  375.   typ.size := adr + (adr MOD 2); typ.link := OCT.topScope.right;
  376.   CheckUndefPointerTypes ();
  377.   fld0 := OCT.topScope.right;
  378.   WHILE fld0 # NIL DO
  379.     (* OCG.TraceIn (mname, "WHILE2"); *)
  380.     fld1 := fld0.link; fld0.link := NIL;
  381.     fld0.left := fld1; fld0.right := NIL;
  382.     fld0 := fld1
  383.     (* ;OCG.TraceOut (mname, "WHILE2"); *)
  384.   END;
  385.   OCT.CloseScope ();
  386.   (* ;OCG.TraceOut (mname, pname); *)
  387. END RecordType;
  388.  
  389. (*------------------------------------*)
  390. PROCEDURE ArrayType (VAR typ : OCT.Struct);
  391.  
  392.   (* CONST pname = "ArrayType"; *)
  393.  
  394.   VAR x : OCT.Item; f, n : INTEGER;
  395.  
  396. BEGIN (* ArrayType *)
  397.   (* OCG.TraceIn (mname, pname); *)
  398.   IF sym # of THEN
  399.     typ := NewStr (Array); ConstExpression (x); f := x.typ.form;
  400.     IF f IN intSet THEN
  401.       IF (x.a0 > 0) & (x.a0 <= MAX (INTEGER)) THEN n := SHORT (x.a0)
  402.       ELSE n := 1; OCS.Mark (68)
  403.       END
  404.     ELSE
  405.       OCS.Mark (51); n := 1
  406.     END;
  407.     typ.n := n;
  408.     IF sym = of THEN OCS.Get (sym); Type (typ.BaseTyp)
  409.     ELSIF sym = comma THEN OCS.Get (sym); ArrayType (typ.BaseTyp)
  410.     ELSE OCS.Mark (34)
  411.     END;
  412.     IF typ.BaseTyp.form = DynArr THEN
  413.       typ.BaseTyp := OCT.undftyp; OCS.Mark (325)
  414.     END;
  415.     typ.size := n * typ.BaseTyp.size;
  416.     INC (typ.size, typ.size MOD 2); (* keep word alignment *)
  417.   ELSE
  418.     typ := NewStr (DynArr); OCS.Get (sym); Type (typ.BaseTyp);
  419.     IF typ.BaseTyp.form = DynArr THEN
  420.       typ.size := typ.BaseTyp.size + 4; typ.adr := typ.BaseTyp.adr + 4
  421.     ELSE
  422.       typ.size := 8; typ.adr := 4
  423.     END
  424.   END
  425.   (* ;OCG.TraceOut (mname, pname); *)
  426. END ArrayType;
  427.  
  428. (*------------------------------------*)
  429. (*
  430.   $  FormalParameters  =  "(" [FPSection {";" FPSection}] ")"
  431.   $    [":" qualident].
  432.   $  FPSection  =  [VAR] ident [RegSpec] {"," ident [RegSpec]}
  433.   $    ":" Type.
  434.   $  RegSpec = "{" ConstExpression "}" [".."].
  435. *)
  436. PROCEDURE FormalParameters (
  437.   VAR resTyp : OCT.Struct; VAR psize : LONGINT; regPars : BOOLEAN);
  438.  
  439.   (* CONST pname = "FormalParameters"; *)
  440.   CONST
  441.     D0 = 0; A5 = 13;
  442.  
  443.   VAR
  444.     mode : SHORTINT; gotUpto : BOOLEAN;
  445.     adr, size : LONGINT; res, reg : OCT.Item;
  446.     par, par1, par2: OCT.Object; typ : OCT.Struct;
  447.  
  448. BEGIN (* FormalParameters *)
  449.   (* OCG.TraceIn (mname, pname); *)
  450.   adr := 0; gotUpto := FALSE;
  451.   (* Make allowance for the receiver of type-bound and libcall procedures *)
  452.   IF OCT.topScope.right # NIL THEN
  453.     par1 := OCT.topScope.right; adr := par1.a0
  454.   ELSE
  455.     par1 := OCT.AllocObj()
  456.   END;
  457.   par2 := par1;
  458.   IF (sym = ident) OR (sym = var) THEN
  459.     LOOP
  460.       IF sym = var THEN
  461.         OCS.Get (sym); IF regPars THEN mode := IndR ELSE mode := Ind END
  462.       ELSIF regPars THEN mode := VarR
  463.       ELSE mode := Var
  464.       END;
  465.       LOOP
  466.         IF sym = ident THEN
  467.           OCT.Insert (OCS.name, par, mode); OCS.Get (sym);
  468.           IF OCT.topScope.right = NIL THEN OCT.topScope.right := par END;
  469.           IF (par # par2) & (par.link = NIL) THEN
  470.             par2.link := par;
  471.             IF par1.link = NIL THEN par1.link := par END;
  472.           END;
  473.           par2 := par
  474.         ELSE OCS.Mark (10)
  475.         END;
  476.  
  477.         IF sym = lbrak THEN (* Register specification *)
  478.           OCS.Get (sym); ConstExpression (reg);
  479.           IF reg.typ.form IN intSet THEN
  480.             IF (reg.a0 >= D0) & (reg.a0 <= A5) THEN par.a0 := reg.a0;
  481.             ELSE OCS.Mark (903)
  482.             END
  483.           ELSE OCS.Mark (902)
  484.           END;
  485.           CheckSym (rbrak);
  486.           IF ~regPars THEN OCS.Mark (901); par.mode := Var; par.a0 := 0 END
  487.         ELSIF regPars THEN OCS.Mark (340)
  488.         END;
  489.  
  490.         IF sym = upto THEN
  491.           IF mode = VarR THEN par.mode := VarArg ELSE OCS.Mark (336) END;
  492.           gotUpto := TRUE; OCS.Get (sym)
  493.         END;
  494.  
  495.         IF sym = comma THEN OCS.Get (sym)
  496.         ELSIF sym = ident THEN OCS.Mark (19)
  497.         ELSIF sym = var THEN OCS.Mark (19); OCS.Get (sym)
  498.         ELSE EXIT
  499.         END;
  500.       END; (* LOOP *)
  501.       CheckSym (colon); Type (typ);
  502.     (*IF (mode = VarArg) & (typ.size > PtrSize) THEN OCS.Mark (338) END;*)
  503.  
  504.       IF ~regPars THEN
  505.         IF mode = Ind  THEN (* VAR param *)
  506.           IF typ.form = Record THEN size := RecDescSize
  507.           ELSIF typ.form = DynArr THEN size := typ.size
  508.           ELSE size := AdrSize
  509.           END
  510.         ELSE
  511.           size := typ.size; IF ODD (size) THEN INC (size) END;
  512.         END;
  513.         WHILE par1.link # NIL DO
  514.           par1 := par1.link; par1.typ := typ;
  515.           DEC (adr, size); par1.a0 := adr
  516.         END;
  517.       ELSE
  518.         WHILE par1.link # NIL DO par1 := par1.link; par1.typ := typ END
  519.       END;
  520.       IF sym = semicolon THEN OCS.Get (sym)
  521.       ELSIF sym = ident THEN OCS.Mark (38)
  522.       ELSE EXIT
  523.       END;
  524.       IF gotUpto THEN OCS.Mark (337) END
  525.     END; (* LOOP *)
  526.   END; (* IF *)
  527.  
  528.   IF ~regPars THEN
  529.     psize := psize - adr;
  530.     IF psize > OCG.ParLimit THEN OCS.Mark (209); psize := 0 END;
  531.     par := OCT.topScope.right;
  532.     WHILE par # NIL DO INC (par.a0, psize); par := par.link END;
  533.   END;
  534.  
  535.   CheckSym (rparen);
  536.   IF sym = colon THEN
  537.     OCS.Get (sym); resTyp := OCT.undftyp;
  538.     IF sym = ident THEN
  539.       qualident (res, FALSE);
  540.       IF res.mode = Typ THEN
  541.         IF res.typ.form <= ProcTyp THEN
  542.           resTyp := res.typ
  543.         ELSE
  544.           OCS.Mark (54)
  545.         END
  546.       ELSE
  547.         OCS.Mark (52)
  548.       END
  549.     ELSE
  550.       OCS.Mark (10)
  551.     END;
  552.   ELSE
  553.     resTyp := OCT.notyp
  554.   END;
  555.   (* ;OCG.TraceOut (mname, pname); *)
  556. END FormalParameters;
  557.  
  558. (*------------------------------------*)
  559. PROCEDURE ProcType (VAR typ : OCT.Struct);
  560.  
  561.   (* CONST pname = "ProcType"; *)
  562.  
  563.   VAR psize : LONGINT;
  564.  
  565. BEGIN (* ProcType *)
  566.   (* OCG.TraceIn (mname, pname); *)
  567.   typ := NewStr (ProcTyp); typ.size := ProcSize;
  568.   IF sym = lparen THEN
  569.     OCS.Get (sym); OCT.OpenScope (OCC.level); psize := ParOrg;
  570.     FormalParameters (typ.BaseTyp, psize, FALSE);
  571.     typ.link := OCT.topScope.right; OCT.CloseScope ();
  572.   ELSE
  573.     typ.BaseTyp := OCT.notyp; typ.link := NIL
  574.   END;
  575.   (* ;OCG.TraceOut (mname, pname); *)
  576. END ProcType;
  577.  
  578. (*------------------------------------*)
  579. PROCEDURE SetPtrBase (ptyp, btyp : OCT.Struct);
  580.  
  581.   (* CONST pname = "SetPtrBase"; *)
  582.  
  583. BEGIN (* SetPtrBase *)
  584.   (* OCG.TraceIn (mname, pname); *)
  585.   ptyp.symbol := OCT.OberonSysPtr;
  586.   IF (ptyp.form IN {CPointer, BPointer}) THEN
  587.     IF btyp.form = DynArr THEN
  588.       ptyp.BaseTyp := OCT.undftyp; OCS.Mark (326)
  589.     ELSE
  590.       ptyp.BaseTyp := btyp
  591.     END
  592.   ELSIF btyp.form IN {Record, Array, DynArr} THEN
  593.     ptyp.BaseTyp := btyp;
  594.     IF btyp.form = DynArr THEN
  595.       ptyp.size := btyp.size; OCC.AllocTypDesc (ptyp)
  596.     END
  597.   ELSE
  598.     ptyp.BaseTyp := OCT.undftyp; OCS.Mark (57)
  599.   END
  600.   (* ;OCG.TraceOut (mname, pname); *)
  601. END SetPtrBase;
  602.  
  603. (*------------------------------------*)
  604. (*
  605.   $  type  =  qualident | ArrayType | RecordType | StructType| PointerType |
  606.   $    ProcedureType.
  607. *)
  608. PROCEDURE Type (VAR typ : OCT.Struct);
  609.  
  610.   (* CONST pname = "Type"; *)
  611.  
  612.   VAR lev : INTEGER; obj : OCT.Object; x : OCT.Item;
  613.  
  614. BEGIN (* Type *)
  615.   (* OCG.TraceIn (mname, pname); *)
  616.   typ := OCT.undftyp;
  617.   IF sym < lparen THEN
  618.     OCS.Mark (12); REPEAT OCS.Get (sym) UNTIL sym >= lparen
  619.   END;
  620.   IF sym = ident THEN
  621.     qualident (x, FALSE);
  622.     IF x.mode = Typ THEN
  623.       typ := x.typ; IF typ = OCT.notyp THEN OCS.Mark (58) END
  624.     ELSE
  625.       OCS.Mark (52)
  626.     END
  627.   ELSIF sym = array THEN
  628.     OCS.Get (sym); ArrayType (typ)
  629.   ELSIF sym = record THEN
  630.     OCS.Get (sym); (*IF ~OCS.createObj THEN OCS.Mark (917) END;*)
  631.     RecordType (typ); OCC.AllocTypDesc (typ); CheckSym (end)
  632.   ELSIF (sym = pointer) OR (sym = cpointer) OR (sym = bpointer) THEN
  633.     typ := NewStr (Pointer);
  634.     IF sym = cpointer THEN
  635.       IF OCS.portableCode THEN OCS.Mark (915) END;
  636.       typ.form := CPointer
  637.     ELSIF sym = bpointer THEN
  638.       IF OCS.portableCode THEN OCS.Mark (915) END;
  639.       typ.form := BPointer
  640.     END;
  641.     OCS.Get (sym); typ.link := NIL; typ.size := PtrSize; CheckSym (to);
  642.     IF sym = ident THEN
  643.       OCT.Find (obj, lev);
  644.       IF obj = NIL THEN (* forward reference *)
  645.         OCT.Insert (OCS.name, obj, Undef); typ.BaseTyp := OCT.undftyp;
  646.         obj.typ := typ; OCS.Get (sym)
  647.       ELSE
  648.         qualident (x, FALSE);
  649.         IF x.mode = Typ THEN SetPtrBase (typ, x.typ)
  650.         ELSE typ.BaseTyp := OCT.undftyp; OCS.Mark (52)
  651.         END
  652.       END
  653.     ELSE Type (x.typ); SetPtrBase (typ, x.typ)
  654.     END
  655.   ELSIF sym = procedure THEN
  656.     OCS.Get (sym); ProcType (typ)
  657.   ELSE
  658.     OCS.Mark (12)
  659.   END;
  660.   IF (sym # semicolon) & (sym # rparen) & (sym # end) THEN
  661.     OCS.Mark (15);
  662.     WHILE (sym < ident) OR (else < sym) & (sym < begin) DO
  663.       OCS.Get (sym)
  664.     END
  665.   END
  666.   (* ;OCG.TraceOut (mname, pname); *)
  667. END Type;
  668.  
  669. (*------------------------------------*)
  670. (*
  671.   $  designator  =  qualident
  672.   $    {"." ident | "[" ExpList "]" | "(" qualident ")" | "^" }.
  673.        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
  674.   $  ExpList  =  expression {"," expression}.
  675. *)
  676. PROCEDURE selector (VAR x, rcvr : OCT.Item);
  677.  
  678.   (* CONST pname = "selector"; *)
  679.  
  680.   VAR fld : OCT.Object; y : OCT.Item; t : OCT.Struct; f : INTEGER;
  681.  
  682. BEGIN (* selector *)
  683.   (* OCG.TraceIn (mname, pname); *)
  684.   rcvr.mode := Undef;
  685.   LOOP
  686.     IF sym = lbrak THEN
  687.       OCS.Get (sym);
  688.       LOOP
  689.         IF (x.typ # NIL) & (x.typ.form IN ptrSet) THEN OCE.DeRef (x) END;
  690.         Expression (y); OCE.Index (x, y);
  691.         IF sym = comma THEN OCS.Get (sym) ELSE EXIT END
  692.       END;
  693.       CheckSym (rbrak)
  694.     ELSIF sym = period THEN
  695.       OCS.Get (sym);
  696.       IF sym = ident THEN
  697.         IF x.typ # NIL THEN
  698.           t := x.typ; f := t.form; IF f IN ptrSet THEN t := t.BaseTyp END;
  699.           IF (t.form = Record) THEN
  700.             OCT.FindField (t, fld);
  701.             IF fld # NIL THEN
  702.               IF fld.mode = Fld THEN
  703.                 IF f IN ptrSet THEN OCE.DeRef (x) END; OCE.Field (x, fld)
  704.               ELSIF fld.mode = TProc THEN
  705.                 rcvr := x; x.mode := TProc; x.a0 := fld.a0; x.a2 := 0;
  706.                 x.obj := fld; x.typ := fld.typ; x.symbol := fld.symbol
  707.               ELSIF fld.mode = LibCall THEN
  708.                 rcvr := x; x.mode := LibCall; x.a0 := fld.a0;
  709.                 x.obj := fld; x.typ := fld.typ
  710.               END
  711.             ELSE
  712.               OCS.Mark (83); x.typ := OCT.undftyp; x.mode := Var;
  713.               x.rdOnly := FALSE
  714.             END
  715.           ELSE
  716.             OCS.Mark (53)
  717.           END;
  718.         ELSE
  719.           OCS.Mark (52) (* ? *)
  720.         END;
  721.         OCS.Get (sym)
  722.       ELSE
  723.         OCS.Mark (10)
  724.       END;
  725.     ELSIF sym = arrow THEN
  726.       IF x.mode = TProc THEN
  727.         IF (rcvr.mode IN {Var,Ind}) & (rcvr.a2 < 0) THEN
  728.           OCT.SuperCall (x.a0, rcvr.typ, fld);
  729.           IF fld # NIL THEN
  730.             x.a2 := -1; x.obj := fld; x.symbol := fld.symbol
  731.           ELSE OCS.Mark (333)
  732.           END
  733.         ELSE OCS.Mark (332)
  734.         END;
  735.         OCS.Get (sym)
  736.       ELSE
  737.         OCS.Get (sym); OCE.DeRef (x)
  738.       END
  739.     ELSIF (sym = lparen) & (x.mode < Typ) & (x.typ.form # ProcTyp) THEN
  740.       OCS.Get (sym);
  741.       IF sym = ident THEN
  742.         qualident (y, FALSE);
  743.         IF y.mode = Typ THEN OCE.TypTest (x, y, FALSE)
  744.         ELSE OCS.Mark (52)
  745.         END
  746.       ELSE
  747.         OCS.Mark (10)
  748.       END;
  749.       CheckSym (rparen)
  750.     ELSE
  751.       EXIT
  752.     END;
  753.   END; (* LOOP *)
  754.   (* ;OCG.TraceOut (mname, pname); *)
  755. END selector;
  756.  
  757. (*------------------------------------*)
  758. PROCEDURE IsParam (obj : OCT.Object) : BOOLEAN;
  759.  
  760. BEGIN (* IsParam *)
  761.   RETURN (obj # NIL) & (obj.mode <= IndR) & (obj.a0 >= 0)
  762. END IsParam;
  763.  
  764. (*------------------------------------*)
  765. PROCEDURE VarArgs
  766.   ( VAR apar : OCT.Item; fpar : OCT.Object;
  767.     VAR stackload : LONGINT; load : BOOLEAN );
  768.  
  769.   VAR x : OCT.Item;
  770.  
  771. BEGIN (* VarArgs *)
  772.   IF sym = comma THEN
  773.     OCS.Get (sym); Expression (x); VarArgs (x, fpar, stackload, FALSE)
  774.   END;
  775.   OCH.VarArg (apar, fpar, stackload, load)
  776. END VarArgs;
  777.  
  778. (*------------------------------------*)
  779. (*
  780.   $  ActualParameters  =  "(" [ExpList] ")" .
  781.   $  ExpList  =  expression {"," expression}.
  782. *)
  783. PROCEDURE ActualParameters (fpar: OCT.Object; VAR stackload : LONGINT);
  784.  
  785.   (* CONST pname = "ActualParameters"; *)
  786.  
  787.   VAR apar : OCT.Item; R : SET;
  788.  
  789. BEGIN (* ActualParameters *)
  790.   (* OCG.TraceIn (mname, pname); *)
  791.   IF sym # rparen THEN
  792.     R := OCC.RegSet;
  793.     LOOP
  794.       Expression (apar);
  795.       IF IsParam (fpar) THEN
  796.         IF fpar.mode = VarArg THEN VarArgs (apar, fpar, stackload, TRUE)
  797.         ELSE OCH.Param (apar, fpar)
  798.         END;
  799.         fpar := fpar.link
  800.       ELSE
  801.         OCS.Mark (64)
  802.       END;
  803.       IF sym = comma THEN OCS.Get (sym)
  804.       ELSIF (lparen <= sym) & (sym <= ident) THEN OCS.Mark (19)
  805.       ELSE EXIT
  806.       END
  807.     END;
  808.     OCC.FreeRegs (R);
  809.   END;
  810.   IF IsParam (fpar) THEN OCS.Mark (65) END
  811.   (* ;OCG.TraceOut (mname, pname); *)
  812. END ActualParameters;
  813.  
  814. (*------------------------------------*)
  815. PROCEDURE StandProcCall (VAR x : OCT.Item);
  816.  
  817.   (* CONST pname = "StandProcCall"; *)
  818.  
  819.   VAR y : OCT.Item; m, n : INTEGER; R : SET;
  820.  
  821. BEGIN (* StandProcCall *)
  822.   (* OCG.TraceIn (mname, pname); *)
  823.   m := SHORT (x.a0); n := 0; R := {};
  824.   IF (sym = lparen) THEN
  825.     OCS.Get (sym);
  826.     IF sym # rparen THEN
  827.       LOOP
  828.         IF m = OCT.pINLINE THEN
  829.           Expression (x); OCP.Inline (x);
  830.         ELSIF n = 0 THEN
  831.           Expression (x); OCP.StPar1 (x, m, R); n := 1
  832.         ELSIF m = OCT.pNEW THEN
  833.           Expression (y); OCP.NewPar (x, y, n); INC (n)
  834.         ELSIF n = 1 THEN
  835.           Expression (y); OCP.StPar2 (x, y, m, R); n := 2;
  836.         ELSIF n = 2 THEN
  837.           Expression (y); OCP.StPar3 (x, y, m, R); n := 3;
  838.         ELSE
  839.           OCS.Mark (64); Expression (y);
  840.         END;
  841.         IF sym = comma THEN
  842.           OCS.Get (sym)
  843.         ELSIF (lparen <= sym) & (sym <= ident) THEN
  844.           OCS.Mark (19)
  845.         ELSE
  846.           EXIT
  847.         END;
  848.       END; (* LOOP *)
  849.       CheckSym (rparen)
  850.     ELSE
  851.       OCS.Get (sym)
  852.     END;
  853.     OCP.StFct (x, m, n, R)
  854.   ELSIF m = OCT.pGC THEN
  855.     OCP.StFct (x, m, n, R)
  856.   ELSE
  857.     OCS.Mark (29)
  858.   END;
  859.   (* ;OCG.TraceOut (mname, pname); *)
  860. END StandProcCall;
  861.  
  862. (*------------------------------------*)
  863. (*
  864.   $  element  =  expression [".." expression].
  865. *)
  866. PROCEDURE Element (VAR x : OCT.Item);
  867.  
  868.   (* CONST pname = "Element"; *)
  869.  
  870.   VAR e1, e2 : OCT.Item;
  871.  
  872. BEGIN (* Element *)
  873.   (* OCG.TraceIn (mname, pname); *)
  874.   Expression (e1);
  875.   IF sym = upto THEN
  876.     OCS.Get (sym); Expression (e2); OCE.Set1 (x, e1, e2)
  877.   ELSE
  878.     OCE.Set0 (x, e1)
  879.   END;
  880.   (* ;OCG.TraceOut (mname, pname); *)
  881. END Element;
  882.  
  883. (*------------------------------------*)
  884. (*
  885.   $  set  =  "{" [element {"," element}] "}".
  886. *)
  887. PROCEDURE Sets (VAR x : OCT.Item);
  888.  
  889.   (* CONST pname = "Sets"; *)
  890.  
  891.   VAR y : OCT.Item;
  892.  
  893. BEGIN (* Sets *)
  894.   (* OCG.TraceIn (mname, pname); *)
  895.   x.typ := OCT.settyp; y.typ := OCT.settyp;
  896.   IF sym # rbrace THEN
  897.     Element (x);
  898.     LOOP
  899.       IF sym = comma THEN
  900.         OCS.Get (sym)
  901.       ELSIF (lparen <= sym) & (sym <= ident) THEN
  902.         OCS.Mark (19)
  903.       ELSE
  904.         EXIT
  905.       END;
  906.       Element (y); OCE.Op (plus, x, y, TRUE) (* x := x + y *)
  907.     END; (* LOOP *)
  908.   ELSE
  909.     x.mode := Con; x.a0 := 0
  910.   END;
  911.   CheckSym (rbrace);
  912.   (* ;OCG.TraceOut (mname, pname); *)
  913. END Sets;
  914.  
  915. (*------------------------------------*)
  916. (*
  917.   $  factor  =  number | CharConstant | string | NIL | set |
  918.   $    designator [ActualParameters] | "(" expression ")" | "~" factor.
  919. *)
  920. PROCEDURE Factor (VAR x : OCT.Item);
  921.  
  922.   (* CONST pname = "Factor"; *)
  923.  
  924.   VAR
  925.     fpar : OCT.Object; rcvr : OCT.Item; R, mask : SET;
  926.     stackload : LONGINT;
  927.  
  928. BEGIN (* Factor *)
  929.   (* OCG.TraceIn (mname, pname); *)
  930.   IF sym < lparen THEN
  931.     OCS.Mark (13);
  932.     REPEAT OCS.Get (sym) UNTIL sym >= lparen
  933.   END;
  934.   x.desc := NIL;
  935.   IF sym = ident THEN
  936.     qualident (x, TRUE); selector (x, rcvr);
  937.     IF x.mode = SProc THEN
  938.       StandProcCall (x)
  939.     ELSIF sym = lparen THEN
  940.       OCH.PrepCall (x, fpar, mask);
  941.       IF x.mode = TProc THEN
  942.         OCC.SaveRegisters (R, rcvr, mask); OCH.Receiver (rcvr, x.obj.link)
  943.       ELSE
  944.         OCC.SaveRegisters (R, x, mask);
  945.       END;
  946.       OCS.Get (sym); stackload := 0; ActualParameters (fpar, stackload);
  947.       IF x.mode = LibCall THEN OCH.CallLibCall (x, rcvr, stackload)
  948.       ELSIF x.mode = TProc THEN OCH.CallTypeBound (x, rcvr)
  949.       ELSE OCH.Call (x)
  950.       END;
  951.       OCC.RestoreRegisters (R, x);
  952.       CheckSym (rparen)
  953.     END;
  954.   ELSIF sym = number THEN
  955.     OCS.Get (sym); x.mode := Con;
  956.     CASE OCS.numtyp OF
  957.       1 : x.typ := OCT.chartyp; x.a0 := OCS.intval
  958.       |
  959.       2 : x.a0 := OCS.intval; OCE.SetIntType (x)
  960.       |
  961.       3 : x.typ := OCT.realtyp; OCE.AssReal (x, OCS.realval)
  962.       |
  963.       4 : x.typ := OCT.lrltyp; OCE.AssLReal (x, OCS.lrlval)
  964.       |
  965.     END; (* CASE OCS.numtyp *)
  966.   ELSIF sym = string THEN
  967.     x.typ := OCT.stringtyp; x.mode := Con;
  968.     OCC.AllocString (OCS.name, OCS.intval, x); OCS.Get (sym);
  969.     IF ~OCS.portableCode THEN
  970.       WHILE sym = string DO
  971.         OCC.ConcatString (OCS.name, OCS.intval, x); OCS.Get (sym)
  972.       END
  973.     END
  974.   ELSIF sym = nil THEN
  975.     OCS.Get (sym); x.typ := OCT.niltyp; x.mode := Con; x.a0 := 0
  976.   ELSIF sym = lparen THEN
  977.     OCS.Get (sym); Expression (x); CheckSym (rparen)
  978.   ELSIF sym = lbrak THEN
  979.     OCS.Get (sym); OCS.Mark (29); Expression (x); CheckSym (rparen)
  980.   ELSIF sym = lbrace THEN
  981.     OCS.Get (sym); Sets (x)
  982.   ELSIF sym = not THEN
  983.     OCS.Get (sym); Factor (x); OCE.MOp (not, x)
  984.   ELSE
  985.     OCS.Mark (13); OCS.Get (sym); x.typ := OCT.undftyp; x.mode := Var;
  986.     x.a0 := 0
  987.   END;
  988.   (* ;OCG.TraceOut (mname, pname); *)
  989. END Factor;
  990.  
  991. (*------------------------------------*)
  992. (*
  993.   $  term  =  factor {MulOperator factor}.
  994.   $  MulOperator  =  "*" | "/" | DIV | MOD | "&" .
  995. *)
  996. PROCEDURE Term (VAR x : OCT.Item);
  997.  
  998.   (* CONST pname = "Term"; *)
  999.  
  1000.   VAR
  1001.     y : OCT.Item; mulop : INTEGER;
  1002.  
  1003. BEGIN (* Term *)
  1004.   (* OCG.TraceIn (mname, pname); *)
  1005.   Factor (x);
  1006.   WHILE (times <= sym) & (sym <= and) DO
  1007.     mulop := sym; OCS.Get (sym);
  1008.     IF mulop = and THEN OCE.MOp (and, x)  END;
  1009.     Factor (y); OCE.Op (mulop, x, y, TRUE);
  1010.   END;
  1011.   (* ;OCG.TraceOut (mname, pname); *)
  1012. END Term;
  1013.  
  1014. (*------------------------------------*)
  1015. (*
  1016.   $  SimpleExpression  =  ["+"|"-"] term {AddOperator term}.
  1017.   $  AddOperator  =  "+" | "-" | OR .
  1018. *)
  1019. PROCEDURE SimpleExpression (VAR x : OCT.Item);
  1020.  
  1021.   (* CONST pname = "SimpleExpression"; *)
  1022.  
  1023.   VAR y : OCT.Item; addop : INTEGER;
  1024.  
  1025. BEGIN (* SimpleExpression *)
  1026.   (* OCG.TraceIn (mname, pname); *)
  1027.   IF sym = minus THEN OCS.Get (sym); Term (x); OCE.MOp (minus, x)
  1028.   ELSIF sym = plus THEN OCS.Get (sym); Term (x); OCE.MOp (plus, x)
  1029.   ELSE Term (x)
  1030.   END;
  1031.   WHILE (plus <= sym) & (sym <= or) DO
  1032.     addop := sym; OCS.Get (sym); IF addop = or THEN OCE.MOp (or, x) END;
  1033.     Term (y); OCE.Op (addop, x, y, TRUE);
  1034.   END;
  1035.   (* ;OCG.TraceOut (mname, pname); *)
  1036. END SimpleExpression;
  1037.  
  1038. (*------------------------------------*)
  1039. (*
  1040.   $  expression  =  SimpleExpression [relation SimpleExpression].
  1041.   $  relation  =  "=" | "#" | "<" | "<=" | ">" | ">=" | IN | IS.
  1042. *)
  1043. PROCEDURE Expression (VAR x : OCT.Item);
  1044.  
  1045.   (* CONST pname = "Expression"; *)
  1046.  
  1047.   VAR
  1048.     y : OCT.Item; relation : INTEGER;
  1049.  
  1050. BEGIN (* Expression *)
  1051.   (* OCG.TraceIn (mname, pname); *)
  1052.   SimpleExpression (x);
  1053.   IF (eql <= sym) & (sym <= geq) THEN
  1054.     relation := sym; OCS.Get (sym);
  1055.     IF x.typ = OCT.booltyp THEN OCE.MOp (relation, x) END;
  1056.     SimpleExpression (y); OCE.Op (relation, x, y, TRUE)
  1057.   ELSIF sym = in THEN
  1058.     OCS.Get (sym); SimpleExpression (y); OCE.In (x, y)
  1059.   ELSIF sym = is THEN
  1060.     IF x.mode >= Typ THEN OCS.Mark (112) END;
  1061.     OCS.Get (sym);
  1062.     IF sym = ident THEN
  1063.       qualident (y, FALSE);
  1064.       IF y.mode = Typ THEN OCE.TypTest (x, y, TRUE) ELSE OCS.Mark (52) END
  1065.     ELSE
  1066.       OCS.Mark (10)
  1067.     END;
  1068.   END;
  1069.   (* ;OCG.TraceOut (mname, pname); *)
  1070. END Expression;
  1071.  
  1072. (*------------------------------------*)
  1073. PROCEDURE Receiver (VAR rtyp : OCT.Struct; libCall : BOOLEAN);
  1074.  
  1075.   (* CONST pname = "Receiver"; *)
  1076.  
  1077.   VAR
  1078.     mode : SHORTINT; mnolev : INTEGER; recvr, obj : OCT.Object;
  1079.     typ : OCT.Struct;
  1080.  
  1081. BEGIN (* Receiver *)
  1082.   (* OCG.TraceIn (mname, pname); *)
  1083.   recvr := NIL; rtyp := OCT.undftyp;
  1084.   IF sym = var THEN mode := Ind; OCS.Get (sym)
  1085.   ELSE mode := Var
  1086.   END;
  1087.   IF sym = ident THEN
  1088.     OCT.Insert (OCS.name, recvr, mode); OCS.Get (sym);
  1089.     OCT.topScope.right := recvr
  1090.   ELSE
  1091.     recvr := OCT.AllocObj (); OCS.Mark (10)
  1092.   END;
  1093.   recvr.typ := OCT.undftyp; recvr.a2 := -1; CheckSym (colon);
  1094.   IF sym = ident THEN
  1095.     OCT.Find (obj, mnolev); IF obj = NIL THEN OCS.Mark (0) END;
  1096.     OCS.Get (sym);
  1097.     IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
  1098.       OCS.Get (sym);
  1099.       IF sym = ident THEN
  1100.         OCT.FindImport (obj, obj); IF obj = NIL THEN OCS.Mark (0) END;
  1101.         OCS.Get (sym)
  1102.       ELSE
  1103.         OCS.Mark (10); obj := NIL
  1104.       END;
  1105.       OCS.Mark (305)
  1106.     END;
  1107.     IF (obj # NIL) & (obj.mode = Typ) THEN
  1108.       typ := obj.typ; IF typ = NIL THEN typ := OCT.undftyp END;
  1109.       IF typ = OCT.undftyp THEN OCS.Mark (58)
  1110.       ELSIF (mode = Ind) & (typ.form # Record) THEN
  1111.         OCS.Mark (307); typ := OCT.undftyp
  1112.       ELSIF (mode = Var) THEN
  1113.         IF libCall THEN
  1114.           IF typ.form # CPointer THEN OCS.Mark (308); typ := OCT.undftyp END
  1115.         ELSE
  1116.           IF typ.form # Pointer THEN OCS.Mark (306); typ := OCT.undftyp END
  1117.         END;
  1118.       END;
  1119.       IF typ.form IN ptrSet THEN rtyp := typ.BaseTyp ELSE rtyp := typ END;
  1120.       recvr.typ := typ;
  1121.       IF libCall THEN recvr.a0 := 0
  1122.       ELSIF mode = Var THEN recvr.a0 := -AdrSize
  1123.       ELSE recvr.a0 := -RecDescSize
  1124.       END
  1125.     ELSE
  1126.       OCS.Mark (52)
  1127.     END;
  1128.   ELSE
  1129.     OCS.Mark (10)
  1130.   END;
  1131.   CheckSym (rparen);
  1132.   (* ;OCG.TraceOut (mname, pname); *)
  1133. END Receiver;
  1134.  
  1135. (*------------------------------------*)
  1136. (*
  1137.   $  LibCallDeclaration = LIBCALL identdef ["*"] LibCallSpec
  1138.   $    [FormalParameters]
  1139.   $  LibCallSpec = "{" identdef "," ConstExpression "}"
  1140. *)
  1141. PROCEDURE LibCallDeclaration ();
  1142.  
  1143.   (* CONST pname = "LibCallDeclaration"; *)
  1144.  
  1145.   VAR
  1146.     proc, par : OCT.Object;
  1147.     psize, dsize : LONGINT;
  1148.     rtyp : OCT.Struct;
  1149.  
  1150. BEGIN (* LibCallDeclaration *)
  1151.   (* OCG.TraceIn (mname, pname); *)
  1152.   IF OCS.portableCode THEN OCS.Mark (915) END;
  1153.   rtyp := OCT.undftyp;
  1154.   IF sym = lparen THEN
  1155.     OCT.OpenScope (OCC.level + 1); OCS.Get (sym); Receiver (rtyp, TRUE)
  1156.   ELSE OCS.Mark (303)
  1157.   END;
  1158.   IF sym = ident THEN
  1159.     (* See if there is a forward declaration already *)
  1160.     OCT.FindField (rtyp, proc);
  1161.     IF proc # NIL THEN (* multiple definition *) OCS.Mark (1) END;
  1162.     proc := OCT.AllocObj(); proc.name := OCT.InsertName (OCS.name);
  1163.     IF rtyp # OCT.undftyp THEN
  1164.       proc.left := rtyp.link; rtyp.link := proc
  1165.     END;
  1166.     CheckMark (proc.visible, FALSE);
  1167.     proc.mode := LibCall; proc.typ := OCT.notyp; proc.link := NIL;
  1168.     proc.a0 := 0; proc.a1 := 0;
  1169.     INC (OCC.level);
  1170.     IF sym = lparen THEN (* Get formal parameters *)
  1171.       psize := 0; OCS.Get (sym); FormalParameters (proc.typ, psize, TRUE);
  1172.       proc.link := OCT.topScope.right
  1173.     END;
  1174.     CheckSym (semicolon);
  1175.     IF sym = minus THEN OCS.Get (sym) END;
  1176.     IF sym = number THEN proc.a0 := -OCS.intval; OCS.Get (sym)
  1177.     ELSE OCS.Mark (17)
  1178.     END;
  1179.     DEC (OCC.level); OCT.CloseScope ()
  1180.   END; (* IF *)
  1181.   (* ;OCG.TraceOut (mname, pname); *)
  1182. END LibCallDeclaration;
  1183.  
  1184. (*------------------------------------*)
  1185. (*
  1186.   $  ProcedureDeclaration  =  ProcedureHeading ";" ProcedureBody ident.
  1187.   $  ProcedureHeading  =  PROCEDURE ["*"] identdef [FormalParameters].
  1188.   $  ForwardDeclaration  =  PROCEDURE "^" identdef [FormalParameters].
  1189. *)
  1190. PROCEDURE ProcedureDeclaration ();
  1191.  
  1192.   (* CONST pname = "ProcedureDeclaration"; *)
  1193.  
  1194.   VAR
  1195.     proc, proc1, par : OCT.Object;
  1196.     rtyp : OCT.Struct;
  1197.     retList, L1 : INTEGER; mode : SHORTINT;
  1198.     body, forward : BOOLEAN;
  1199.     psize, dsize : LONGINT;
  1200.     x : OCT.Item;
  1201.     symbol : OCT.Symbol;
  1202.  
  1203. BEGIN (* ProcedureDeclaration *)
  1204.   (* OCG.TraceIn (mname, pname); *)
  1205.   dsize := 0; proc := NIL; body := TRUE; forward := FALSE; mode := LProc;
  1206.   IF (sym # ident) & (OCC.level = 0) THEN
  1207.     (* Process specifier after procedure symbol *)
  1208.     IF sym = times THEN mode := XProc; OCS.Get (sym)
  1209.     ELSIF sym = arrow THEN forward := TRUE; body := FALSE; OCS.Get (sym)
  1210.     END;
  1211.     IF sym = lparen THEN (* Type-bound procedure *)
  1212.       mode := TProc; OCS.Get (sym); OCT.OpenScope (OCC.level + 1);
  1213.       Receiver (rtyp, FALSE)
  1214.     ELSIF sym # ident THEN OCS.Mark (10)
  1215.     END;
  1216.   END;
  1217.  
  1218.   IF sym = ident THEN
  1219.     IF mode = TProc THEN
  1220.       (*
  1221.         We must be aware of two possibilities for type-bound procedures:
  1222.         - There is a forward declaration for the *same* type
  1223.           (proc1.a1 = rtyp.n) & (proc1.a2 = -1);
  1224.         - It is a redefinition of a procedure from a base type
  1225.           (proc1.a1 # rtyp.n) & (proc1.a2 = 0).
  1226.       *)
  1227.       OCT.FindField (rtyp, proc1);
  1228.       IF proc1 # NIL THEN
  1229.         IF proc1.mode # TProc THEN (* Name used for a record field *)
  1230.           OCS.Mark (329); proc1 := NIL
  1231.         ELSIF (proc1.a1 = rtyp.n) & (proc1.a2 = 0) THEN
  1232.           (* Procedure already declared *)
  1233.           OCS.Mark (1); proc1 := NIL
  1234.         END
  1235.       END;
  1236.       proc := OCT.AllocObj (); proc.name := OCT.InsertName (OCS.name);
  1237.       CheckMark (proc.visible, FALSE);
  1238.       (* Assign a procedure number *)
  1239.       IF proc1 # NIL THEN proc.a0 := proc1.a0
  1240.       ELSE proc.a0 := OCT.NextProc (rtyp)
  1241.       END;
  1242.       (* Note the type level *)
  1243.       proc.a1 := rtyp.n;
  1244.       (* Prepare to parse the parameters *)
  1245.       INC (OCC.level);
  1246.       IF (proc.visible = OCT.Exp) & ~OCS.longVars THEN
  1247.         (* return address + frame ptr + global var base *)
  1248.         psize := XParOrg
  1249.       ELSE
  1250.         (* return address + frame ptr *)
  1251.         psize := ParOrg
  1252.       END
  1253.     ELSE
  1254.       (* See if there is a forward declaration already *)
  1255.       IF OCC.level = 0 THEN OCT.Find (proc1, L1) ELSE proc1 := NIL END;
  1256.       IF (proc1 # NIL) & (proc1.a2 < 0) THEN
  1257.         (* there exists a corresponding forward declaration *)
  1258.         proc := OCT.AllocObj (); CheckMark (proc.visible, FALSE);
  1259.         IF proc.visible = OCT.Exp THEN mode := XProc END;
  1260.       ELSE
  1261.         IF proc1 # NIL THEN OCS.Mark (1); proc1 := NIL END;
  1262.         OCT.Insert (OCS.name, proc, mode); CheckMark (proc.visible, FALSE);
  1263.         IF (proc.visible = OCT.Exp) & (mode = LProc) THEN mode := XProc END;
  1264.         IF (proc.visible # OCT.Exp) & (OCC.level > 0) THEN
  1265.           proc.a0 := procNo; INC (procNo)
  1266.         ELSE
  1267.           proc.a0 := 0
  1268.         END
  1269.       END;
  1270.  
  1271.       INC (OCC.level); OCT.OpenScope (OCC.level);
  1272.       (* work out offset of procedure parameters *)
  1273.       IF (mode = LProc) & (OCC.level > 1) THEN
  1274.         psize := LParOrg (* return address + frame ptr + static link *)
  1275.       ELSIF (mode = XProc) & ~OCS.longVars THEN
  1276.         psize := XParOrg (* return address + frame ptr + global var base *)
  1277.       ELSE
  1278.         psize := ParOrg  (* return address + frame ptr *)
  1279.       END;
  1280.     END;
  1281.  
  1282.     IF sym = lbrak THEN (* Foreign procedure *)
  1283.       IF mode = TProc THEN OCS.Mark (344)
  1284.       ELSIF forward THEN OCS.Mark (343); forward := FALSE
  1285.       END;
  1286.       mode := FProc; body := FALSE; OCS.Get (sym);
  1287.       IF sym = string THEN
  1288.         NEW (symbol, Str.Length (OCS.name) + 1); COPY (OCS.name, symbol^);
  1289.         OCS.Get (sym)
  1290.       ELSE OCS.Mark (342); symbol := NIL
  1291.       END;
  1292.       CheckSym (rbrak);
  1293.     END;
  1294.  
  1295.     proc.mode := mode; proc.typ := OCT.notyp;
  1296.     IF forward THEN proc.a2 := -1 ELSE proc.a2 := 0 END;
  1297.  
  1298.     IF sym = lparen THEN (* Get formal parameters *)
  1299.       OCS.Get (sym); FormalParameters (proc.typ, psize, (mode = FProc));
  1300.     ELSIF mode = TProc THEN (* fixup receiver parameter *)
  1301.       par := OCT.topScope.right;
  1302.       IF par # NIL THEN
  1303.         par.a0 := psize;
  1304.         IF par.mode = Ind THEN INC (psize, RecDescSize)
  1305.         ELSE INC (psize, AdrSize)
  1306.         END
  1307.       END
  1308.     END;
  1309.     proc.link := OCT.topScope.right;
  1310.  
  1311.     IF proc1 # NIL THEN
  1312.       IF mode = TProc THEN (* forward declaration or redefinition *)
  1313.         IF
  1314.           (proc1.a2 = 0) & (rtyp.strobj.visible = OCT.Exp)
  1315.           & (proc1.visible = OCT.Exp) & (proc.visible # OCT.Exp)
  1316.         THEN (* Redefined procedure must be exported *)
  1317.           OCS.Mark (330)
  1318.         END;
  1319.         OCH.CompareParLists (proc.link.link, proc1.link.link);
  1320.       ELSE (* forward declaration *)
  1321.         OCH.CompareParLists (proc.link, proc1.link);
  1322.       END;
  1323.       IF proc.typ # proc1.typ THEN OCS.Mark (118) END;
  1324.       IF proc1.a2 < 0 THEN (* forward declaration *)
  1325.         proc.link := NIL; OCT.FreeObj (proc);
  1326.         proc := proc1; OCT.FreeObj (proc.link);
  1327.         proc.link := OCT.topScope.right
  1328.       END
  1329.     END;
  1330.     IF forward OR (proc.a2 = 0) THEN
  1331.       IF mode = TProc THEN
  1332.         IF rtyp # OCT.undftyp THEN
  1333.           proc.left := rtyp.link; rtyp.link := proc;
  1334.           OCT.MakeTProcSymbol (rtyp.symbol, proc)
  1335.         END
  1336.       ELSIF mode = FProc THEN
  1337.         proc.symbol := symbol
  1338.       ELSE
  1339.         OCT.MakeProcSymbol (proc)
  1340.       END
  1341.     END;
  1342.     IF ~forward THEN proc.a2 := 0 END;
  1343.  
  1344.     IF body THEN
  1345.       CheckSym (semicolon); OCT.topScope.typ := proc.typ;
  1346.  
  1347.       OCH.StartProcedure (proc);
  1348.       Block (proc, dsize, retList);
  1349.       proc.link := OCT.topScope.right; (* update *)
  1350.       OCH.EndProcBody (proc, SHORT (psize), retList, dsize # 0);
  1351.       OCS.ResetProcSwitches ();
  1352.  
  1353.       (* Check size of local variables *)
  1354.       IF dsize > ProcVarSize THEN OCS.Mark (209); dsize := 0 END;
  1355.  
  1356.       (* Check name at end of procedure *)
  1357.       IF sym = ident THEN
  1358.         IF OCT.InsertName (OCS.name) # proc.name THEN OCS.Mark (4) END;
  1359.         OCS.Get (sym)
  1360.       ELSE
  1361.         OCS.Mark (10)
  1362.       END;
  1363.     END; (* IF *)
  1364.  
  1365.     IF proc.link # NIL THEN
  1366.       par := proc.link; WHILE IsParam (par.link) DO par := par.link END;
  1367.       (*OCT.FreeObj (par.link);*) par.link := NIL
  1368.     END;
  1369.     DEC (OCC.level); OCT.CloseScope ()
  1370.   END; (* IF *)
  1371.   (* ;OCG.TraceOut (mname, pname); *)
  1372. END ProcedureDeclaration;
  1373.  
  1374. (*------------------------------------*)
  1375. (*
  1376.   $  CaseLabelList  =  CaseLabels {"," CaseLabels}.
  1377.   $  CaseLabels  =  ConstExpression [".." ConstExpression].
  1378. *)
  1379. PROCEDURE CaseLabelList (
  1380.   LabelForm : INTEGER; VAR n : INTEGER; VAR tab : ARRAY OF OCH.LabelRange);
  1381.  
  1382.   (* CONST pname = "CaseLabelList"; *)
  1383.  
  1384.   VAR
  1385.     x, y : OCT.Item; i, f, g : INTEGER;
  1386.  
  1387. BEGIN (* CaseLabelList *)
  1388.   (* OCG.TraceIn (mname, pname); *)
  1389.   IF ~(LabelForm IN labeltyps) THEN OCS.Mark (61) END;
  1390.   LOOP
  1391.     ConstExpression (x); f := x.typ.form;
  1392.     IF (f = String) & (x.a1 <= 2) THEN
  1393.       x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  1394.     END;
  1395.     IF f IN intSet THEN
  1396.       IF LabelForm < f THEN OCS.Mark (60) END
  1397.     ELSIF f # LabelForm THEN
  1398.       OCS.Mark (60)
  1399.     END;
  1400.     IF sym = upto THEN
  1401.       OCS.Get (sym); ConstExpression (y); g := y.typ.form;
  1402.       IF (g = String) & (y.a1 <= 2) THEN
  1403.         y.a0 := y.a2; y.typ := OCT.chartyp; g := Char
  1404.       END;
  1405.       IF (g # f) & ~((f IN intSet) & (g IN intSet)) THEN
  1406.         OCS.Mark (60)
  1407.       END;
  1408.       IF y.a0 < x.a0 THEN OCS.Mark (63); y.a0 := x.a0 END
  1409.     ELSE
  1410.       y := x
  1411.     END;
  1412.     (* enter label range into ordered table *)
  1413.     i := n;
  1414.     IF i < NofCases THEN
  1415.       LOOP
  1416.         IF i = 0 THEN EXIT END;
  1417.         IF tab [i-1].low <= y.a0 THEN
  1418.           IF tab[i-1].high >= x.a0 THEN OCS.Mark (62) END;
  1419.           EXIT
  1420.         END;
  1421.         tab [i] := tab[i-1]; DEC (i)
  1422.       END; (* LOOP *)
  1423.       tab [i].low := SHORT (x.a0); tab[i].high := SHORT (y.a0);
  1424.       tab[i].label := OCC.pc; INC (n)
  1425.     ELSE
  1426.       OCS.Mark (213)
  1427.     END;
  1428.     IF sym = comma THEN
  1429.       OCS.Get (sym)
  1430.     ELSIF (sym = number) OR (sym = ident) THEN
  1431.       OCS.Mark (19)
  1432.     ELSE
  1433.       EXIT
  1434.     END;
  1435.   END; (* LOOP *)
  1436.   (* ;OCG.TraceOut (mname, pname); *)
  1437. END CaseLabelList;
  1438.  
  1439. (*------------------------------------*)
  1440. (*
  1441.   $  StatementSequence  =  statement {";" statement}.
  1442.  
  1443.   $  statement  =  [assignment | ProcedureCall |
  1444.   $    IfStatement | CaseStatement | WhileStatement | RepeatStatement |
  1445.   $    LoopStatement | WithStatement | EXIT | RETURN [expression] ].
  1446.  
  1447.   $  assignment  =  designator ":=" expression.
  1448.  
  1449.   $  ProcedureCall  =  designator [ActualParameters].
  1450.  
  1451.   $  IfStatement  =  IF expression THEN StatementSequence
  1452.   $    {ELSIF expression THEN StatementSequence}
  1453.   $    [ELSE StatementSequence]
  1454.   $    END.
  1455.  
  1456.   $  CaseStatement  =  CASE expression OF case {"|" case}
  1457.   $    [ELSE StatementSequence] END.
  1458.   $  case  =  [CaseLabelList ":" StatementSequence].
  1459.  
  1460.   $  WhileStatement  =  WHILE expression DO StatementSequence END.
  1461.  
  1462.   $  RepeatStatement  =   REPEAT StatementSequence UNTIL expression.
  1463.  
  1464.   $  LoopStatement  =  LOOP StatementSequence END.
  1465.  
  1466.   $  WithStatement  =  WITH qualident ":" qualident DO
  1467.   $    StatementSequence END.
  1468. *)
  1469. PROCEDURE StatSeq (VAR retList : INTEGER);
  1470.  
  1471.   (* CONST pname = "StatSeq"; *)
  1472.  
  1473.   VAR
  1474.     fpar : OCT.Object; xtyp : OCT.Struct; stackload : LONGINT;
  1475.     x, rcvr, y, z, step : OCT.Item; L0, L1, ExitIndex : INTEGER;
  1476.     R, R1, mask : SET;
  1477.  
  1478.   (*------------------------------------*)
  1479.   PROCEDURE CasePart ();
  1480.  
  1481.     (* CONST pname = "CasePart"; *)
  1482.  
  1483.     VAR
  1484.       x : OCT.Item; n, L0, L1, L2 : INTEGER;
  1485.       tab : ARRAY NofCases OF OCH.LabelRange;
  1486.  
  1487.   BEGIN (* CasePart *)
  1488.     (* OCG.TraceIn (mname, pname); *)
  1489.     n := 0; L1 := 0;
  1490.     Expression (x); OCH.CaseIn (x, L0); CheckSym (of);
  1491.     LOOP
  1492.       IF sym < bar THEN
  1493.         CaseLabelList (x.typ.form, n, tab);
  1494.         CheckSym (colon); StatSeq (retList); OCH.FJ (L1)
  1495.       END;
  1496.       IF sym = bar THEN OCS.Get (sym) ELSE EXIT END
  1497.     END; (* LOOP *)
  1498.     L2 := OCC.pc;
  1499.     IF sym = else THEN
  1500.       OCS.Get (sym); StatSeq (retList); OCH.FJ (L1)
  1501.     ELSE
  1502.       IF OCS.caseCheck THEN OCC.Trap (OCC.CaseCheck)
  1503.       ELSE OCH.FJ (L1)
  1504.       END
  1505.     END;
  1506.     OCH.CaseOut (x, L0, L1, L2, n, tab)
  1507.     (* ;OCG.TraceOut (mname, pname); *)
  1508.   END CasePart;
  1509.  
  1510. BEGIN (* StatSeq *)
  1511.   (* OCG.TraceIn (mname, pname); *)
  1512.   R := OCC.RegSet;
  1513.   LOOP
  1514.     IF sym < ident THEN (* illegal symbol *)
  1515.       OCS.Mark (14);
  1516.       REPEAT OCS.Get (sym) UNTIL sym >= ident;
  1517.     END;
  1518.  
  1519.     IF sym = ident THEN (* assignment or procedure call *)
  1520.       qualident (x, TRUE); selector (x, rcvr);
  1521.       IF sym = becomes THEN (* assignment *)
  1522.         OCS.Get (sym); Expression (y); OCH.Assign (x, y, FALSE)
  1523.       ELSIF sym = eql THEN (* typo ? *)
  1524.         OCS.Mark (33); OCS.Get (sym); Expression (y);
  1525.         OCH.Assign (x, y, FALSE)
  1526.       ELSIF x.mode = SProc THEN (* standard procedure call *)
  1527.         StandProcCall (x); IF x.typ # OCT.notyp THEN OCS.Mark (55) END
  1528.       ELSE (* procedure call *)
  1529.         OCH.PrepCall (x, fpar, mask);
  1530.         IF x.mode = TProc THEN
  1531.           OCC.SaveRegisters (R1, rcvr, mask);
  1532.           OCH.Receiver (rcvr, x.obj.link)
  1533.         ELSE
  1534.           OCC.SaveRegisters (R1, x, mask);
  1535.         END;
  1536.         stackload := 0;
  1537.         IF sym = lparen THEN
  1538.           OCS.Get (sym); ActualParameters (fpar, stackload);
  1539.           CheckSym (rparen);
  1540.         ELSIF IsParam (fpar) THEN (* parameters missing *)
  1541.           OCS.Mark (65)
  1542.         END;
  1543.         IF x.mode = LibCall THEN OCH.CallLibCall (x, rcvr, stackload)
  1544.         ELSIF x.mode = TProc THEN OCH.CallTypeBound (x, rcvr)
  1545.         ELSE OCH.Call (x)
  1546.         END;
  1547.         OCC.RestoreRegisters (R1, x);
  1548.         IF x.typ # OCT.notyp THEN OCS.Mark (55) END;
  1549.       END;
  1550.       (*OCT.FreeDesc (x.desc);*)
  1551.  
  1552.     ELSIF sym = if THEN (* if statement *)
  1553.       OCS.Get (sym); Expression (x); OCH.CFJ (x, L0); OCC.FreeRegs (R);
  1554.       CheckSym (then); StatSeq (retList); L1 := 0;
  1555.       WHILE sym = elsif DO
  1556.         OCS.Get (sym); OCH.FJ (L1); OCC.FixLink (L0);
  1557.         Expression (x); OCH.CFJ (x, L0); OCC.FreeRegs (R);
  1558.         CheckSym (then); StatSeq (retList)
  1559.       END;
  1560.       IF sym = else THEN
  1561.         OCS.Get (sym); OCH.FJ (L1); OCC.FixLink (L0);
  1562.         StatSeq (retList)
  1563.       ELSE
  1564.         OCC.FixLink (L0)
  1565.       END;
  1566.       OCC.FixLink (L1); CheckSym (end)
  1567.  
  1568.     ELSIF sym = case THEN (* case statement *)
  1569.       OCS.Get (sym); CasePart (); CheckSym (end)
  1570.  
  1571.     ELSIF sym = while THEN (* while statement *)
  1572.       OCS.Get (sym); L1 := OCC.pc;
  1573.       Expression (x); OCH.CFJ (x, L0); OCC.FreeRegs (R);
  1574.       CheckSym (do); StatSeq (retList); OCH.BJ (L1); OCC.FixLink (L0);
  1575.       CheckSym (end)
  1576.  
  1577.     ELSIF sym = repeat THEN (* repeat statement *)
  1578.       OCS.Get (sym); L0 := OCC.pc; StatSeq (retList);
  1579.       IF sym = until THEN
  1580.         OCS.Get (sym); Expression (x); OCH.CBJ (x, L0)
  1581.       ELSE
  1582.         OCS.Mark (43)
  1583.       END;
  1584.  
  1585.     ELSIF sym = for THEN
  1586.       OCS.Get (sym);
  1587.       IF sym = ident THEN
  1588.         qualident (x, FALSE);
  1589.         IF x.lev < 0 THEN OCS.Mark (327)
  1590.         ELSIF ~(x.typ.form IN intSet) THEN OCS.Mark (314)
  1591.         END;
  1592.         CheckSym (becomes); Expression (y);
  1593.         IF ~(y.typ.form IN intSet) THEN OCS.Mark (315) END;
  1594.         CheckSym (to); Expression (z);
  1595.         IF ~(z.typ.form IN intSet) THEN OCS.Mark (315) END;
  1596.         IF sym = by THEN OCS.Get (sym); ConstExpression (step);
  1597.           IF ~(step.typ.form IN intSet) THEN OCS.Mark (17)
  1598.           ELSIF step.a0 = 0 THEN OCS.Mark (316); step.a0 := 1
  1599.           END;
  1600.         ELSE step.mode := Con; step.a0 := 1; step.typ := OCT.sinttyp
  1601.         END;
  1602.         OCH.BeginFor (x, y, z, step, L0, L1); OCC.FreeRegs (R);
  1603.         IF z.mode = Reg THEN OCC.ReserveReg (SHORT (z.a0)) END;
  1604.         CheckSym (do); StatSeq (retList); OCH.EndFor (x, step, L0, L1);
  1605.         IF z.mode = Reg THEN OCC.UnReserveReg (SHORT (z.a0)) END;
  1606.         CheckSym (end)
  1607.       ELSE OCS.Mark (10)
  1608.       END;
  1609.  
  1610.     ELSIF sym = loop THEN (* loop statement *)
  1611.       OCS.Get (sym); ExitIndex := ExitNo; INC (LoopLevel);
  1612.       L0 := OCC.pc; StatSeq (retList); OCH.BJ (L0); DEC (LoopLevel);
  1613.       WHILE ExitNo > ExitIndex DO
  1614.         DEC (ExitNo); OCC.fixup (LoopExit [ExitNo])
  1615.       END;
  1616.       CheckSym (end)
  1617.  
  1618.     ELSIF sym = with THEN (* regional type guard *)
  1619.       L1 := 0;
  1620.       REPEAT
  1621.         OCS.Get (sym); x.obj := NIL; xtyp := NIL;
  1622.         IF sym = ident THEN (* got variable OK *)
  1623.           qualident (x, FALSE); CheckSym (colon);
  1624.           IF sym = ident THEN
  1625.             qualident (y, FALSE);
  1626.             IF y.mode = Typ THEN (* got type OK *)
  1627.               IF x.obj # NIL THEN
  1628.                 xtyp := x.typ; x.obj.typ := y.typ; OCE.TypTest (x, y, TRUE)
  1629.               ELSE OCS.Mark (130) (* variable has anonymous type *)
  1630.               END
  1631.             ELSE OCS.Mark (52) (* not a type *)
  1632.             END
  1633.           ELSE OCS.Mark (10)
  1634.           END
  1635.         ELSE OCS.Mark (10)
  1636.         END;
  1637.         CheckSym (do); OCC.FreeRegs (R); OCH.CFJ (x, L0); StatSeq (retList);
  1638.         IF (sym = bar) OR (sym = else) THEN
  1639.           OCH.FJ (L1); OCC.FixLink (L0)
  1640.         END;
  1641.         IF xtyp # NIL THEN x.obj.typ := xtyp END;
  1642.       UNTIL sym # bar;
  1643.       IF sym = else THEN OCS.Get (sym); StatSeq (retList)
  1644.       ELSIF OCS.typeCheck THEN OCC.TypeTrap (L0)
  1645.       ELSE OCC.FixLink (L0)
  1646.       END;
  1647.       OCC.FixLink (L1);
  1648.       CheckSym (end);
  1649.  
  1650.     ELSIF sym = exit THEN (* Loop exit statement *)
  1651.       OCS.Get (sym); L0 := 0; OCH.FJ (L0);
  1652.       IF LoopLevel = 0 THEN OCS.Mark (45)
  1653.       ELSIF ExitNo < NumLoopLevels THEN
  1654.         LoopExit [ExitNo] := L0; INC (ExitNo)
  1655.       ELSE OCS.Mark (214)
  1656.       END;
  1657.  
  1658.     ELSIF sym = return THEN (* Procedure return statement *)
  1659.       OCS.Get (sym);
  1660.       IF OCC.level > 0 THEN (* Return from procedure *)
  1661.         IF sym < semicolon THEN
  1662.           Expression (x); OCH.Result (x, OCT.topScope.typ)
  1663.         ELSIF OCT.topScope.typ # OCT.notyp THEN (* expression missing *)
  1664.           OCS.Mark (124)
  1665.         END;
  1666.         OCH.FJ (retList)
  1667.       ELSE (* return from module body *)
  1668.         IF sym < semicolon THEN Expression (x); OCS.Mark (124) END;
  1669.         OCH.FJ (retList)
  1670.       END;
  1671.     END;
  1672.  
  1673.     OCC.FreeRegs (R);
  1674.  
  1675.     IF sym = semicolon THEN
  1676.       OCS.Get (sym)
  1677.     ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN
  1678.       OCS.Mark (38)
  1679.     ELSE
  1680.       EXIT
  1681.     END;
  1682.   END; (* LOOP *)
  1683.   (* ;OCG.TraceOut (mname, pname); *)
  1684. END StatSeq;
  1685.  
  1686. (*------------------------------------*)
  1687. (*
  1688.   $  module  =  MODULE ident ";"  [ImportList]
  1689.   $    DeclarationSequence [BEGIN StatementSequence] END ident "." .
  1690.        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
  1691.  
  1692.   $  ProcedureBody  =  DeclarationSequence [BEGIN StatementSequence] END.
  1693.                        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
  1694.  
  1695.   $  DeclarationSequence  =  {CONST {ConstantDeclaration ";"} |
  1696.   $      TYPE {TypeDeclaration ";"} | VAR {VariableDeclaration ";"}}
  1697.   $      {ProcedureDeclaration ";" | ForwardDeclaration ";"}.
  1698. *)
  1699. PROCEDURE Block (
  1700.   proc : OCT.Object; VAR dsize : LONGINT; VAR retList : INTEGER);
  1701.  
  1702.   (* CONST pname = "Block"; *)
  1703.  
  1704.   VAR
  1705.     typ, forward : OCT.Struct;
  1706.     obj, first, last : OCT.Object;
  1707.     x : OCT.Item;
  1708.     L0 : INTEGER;
  1709.     adr, size : LONGINT;
  1710.     mk : SHORTINT;
  1711.     id0 : ARRAY 32 OF CHAR;
  1712.  
  1713. BEGIN (* Block *)
  1714.   (* OCG.TraceIn (mname, pname); *)
  1715.   (* Calculate base address of variables *)
  1716.   IF OCC.level = 0 THEN
  1717.     (* +ve offsets from module variable base *)
  1718.     adr := dsize;
  1719.   ELSE
  1720.     (* -ve offsets from frame pointer *)
  1721.     adr := -dsize;
  1722.   END;
  1723.  
  1724.   last := OCT.topScope.right;
  1725.   IF last # NIL THEN
  1726.     WHILE last.link # NIL DO last := last.link END;
  1727.   END;
  1728.  
  1729.   LOOP
  1730.     IF sym = const THEN (* Constant declaration(s) *)
  1731.       OCS.Get (sym);
  1732.       WHILE sym = ident DO
  1733.         COPY (OCS.name, id0); CheckMark (mk, FALSE);
  1734.         IF sym = eql THEN
  1735.           OCS.Get (sym); ConstExpression (x)
  1736.         ELSIF sym = becomes THEN
  1737.           OCS.Mark (9); OCS.Get (sym); ConstExpression (x)
  1738.         ELSE
  1739.           OCS.Mark (9)
  1740.         END;
  1741.  
  1742.         (* Enforce limitation on aliasing imported string constants *)
  1743.         IF (x.lev < 0) & (x.typ = OCT.stringtyp) & (x.a1 > 2) THEN
  1744.           OCS.Mark (323)
  1745.         END;
  1746.  
  1747.         (* Insert in symbol table *)
  1748.         OCT.Insert (id0, obj, SHORT (x.mode));
  1749.         obj.typ := x.typ; obj.a0 := x.a0; obj.a1 := x.a1; obj.a2 := x.a2;
  1750.         obj.visible := mk; obj.symbol := x.symbol;
  1751.  
  1752.         CheckSym (semicolon)
  1753.       END; (* WHILE *)
  1754.     END; (* IF *)
  1755.  
  1756.     IF sym = type THEN (* Type declaration(s) *)
  1757.       OCS.Get (sym);
  1758.       WHILE sym = ident DO
  1759.         (* Insert in symbol table *)
  1760.         typ := OCT.undftyp; OCT.Insert (OCS.name, obj, Typ);
  1761.         forward := obj.typ; obj.typ := OCT.notyp;
  1762.         CheckMark (obj.visible, FALSE);
  1763.  
  1764.         IF sym = eql THEN
  1765.           OCS.Get (sym); Type (typ);
  1766.         ELSIF (sym = becomes) OR (sym = colon) THEN
  1767.           OCS.Mark (9);
  1768.           OCS.Get (sym); Type (typ);
  1769.         ELSE
  1770.           OCS.Mark (9); typ := OCT.undftyp
  1771.         END;
  1772.         IF typ.form = DynArr THEN typ := OCT.undftyp; OCS.Mark (325) END;
  1773.  
  1774.         obj.typ := typ;
  1775.         IF typ.strobj = NIL THEN typ.strobj := obj END;
  1776.         IF forward # NIL THEN (* fixup *) SetPtrBase (forward, typ) END;
  1777.  
  1778.         CheckSym (semicolon);
  1779.       END; (* WHILE *)
  1780.     END; (* IF *)
  1781.  
  1782.     IF sym = var THEN (* Variable declarations *)
  1783.       (*IF (OCC.level = 0) & ~OCS.createObj THEN OCS.Mark (918) END;*)
  1784.       OCS.Get (sym);
  1785.       WHILE sym = ident DO
  1786.         (* Insert in symbol table *)
  1787.         OCT.Insert (OCS.name, obj, Var); CheckMark (obj.visible, TRUE);
  1788.         IF (obj # last) & (obj.link = NIL) THEN
  1789.           IF last = NIL THEN OCT.topScope.right := obj
  1790.           ELSE last.link := obj
  1791.           END;
  1792.           first := obj; last := obj
  1793.         END;
  1794.  
  1795.         LOOP (* Get identifier list *)
  1796.           IF sym = comma THEN     OCS.Get (sym)
  1797.           ELSIF sym = ident THEN  OCS.Mark (19)
  1798.           ELSE                    EXIT
  1799.           END;
  1800.           IF sym = ident THEN
  1801.             OCT.Insert (OCS.name, obj, Var); CheckMark (obj.visible, TRUE);
  1802.             IF (obj # last) & (obj.link = NIL) THEN
  1803.               last.link := obj; last := obj
  1804.             END
  1805.           ELSE
  1806.             OCS.Mark (10)
  1807.           END;
  1808.         END; (* LOOP *)
  1809.  
  1810.         (* Get type *)
  1811.         CheckSym (colon); Type (typ);
  1812.         IF typ.form = DynArr THEN typ := OCT.undftyp; OCS.Mark (325) END;
  1813.         size := typ.size;
  1814.         IF (size > 1) & ODD (size) THEN INC (size) END;
  1815.  
  1816.         (* Calculate variable addresses *)
  1817.         IF OCC.level = 0 THEN (* Global variable *)
  1818.           IF (size > 1) & ODD (adr) THEN INC (adr) END; (* Word align *)
  1819.           WHILE first # NIL DO
  1820.             first.typ := typ; first.a0 := adr; INC (adr, size);
  1821.             first := first.link
  1822.           END;
  1823.         ELSE                  (* Local procedure variable *)
  1824.           IF (size > 1) & ODD (adr) THEN DEC (adr) END; (* Word align *)
  1825.           WHILE first # NIL DO
  1826.             first.typ := typ; DEC (adr, size); first.a0 := adr;
  1827.             first := first.link
  1828.           END;
  1829.         END;
  1830.  
  1831.         CheckSym (semicolon);
  1832.       END; (* WHILE *)
  1833.     END; (* IF *)
  1834.     IF (sym < const) OR (sym > var) THEN EXIT END;
  1835.   END; (* LOOP *)
  1836.  
  1837.   CheckUndefPointerTypes ();
  1838.  
  1839.   WHILE sym = libcall DO (* Library call declarations *)
  1840.     OCS.Get (sym); LibCallDeclaration (); CheckSym (semicolon)
  1841.   END;
  1842.  
  1843.   WHILE sym = procedure DO (* Procedure declarations *)
  1844.     OCS.Get (sym); ProcedureDeclaration (); CheckSym (semicolon)
  1845.   END;
  1846.  
  1847.   CheckForwardProcs ();
  1848.  
  1849.   (* Calculate data size (rounded up to even value) *)
  1850.   IF OCC.level = 0 THEN dsize := adr
  1851.   ELSE                  dsize := -adr
  1852.   END;
  1853.   IF ODD (dsize) THEN INC (dsize) END;
  1854.  
  1855.   retList := 0; (* set up list of return branches *)
  1856.   IF OCC.level = 0 THEN OCH.StartModuleBody (dsize, retList) END;
  1857.   IF sym = begin THEN (* Main body of block *)
  1858.     (*IF (OCC.level <= 1) & ~OCS.createObj THEN OCS.Mark (919) END;*)
  1859.     IF OCC.level > 0 THEN OCH.StartProcBody (proc, dsize) END;
  1860.     OCS.Get (sym); StatSeq (retList);
  1861.   END;
  1862.  
  1863.   CheckSym (end);
  1864.   (* ;OCG.TraceOut (mname, pname); *)
  1865. END Block;
  1866.  
  1867. (*------------------------------------*)
  1868. (*
  1869.   $  module  =  MODULE ident ";"  [ImportList] DeclarationSequence
  1870.   $      [BEGIN StatementSequence] END ident "." .
  1871.   $  ImportList  =  IMPORT import {"," import} ";" .
  1872.   $  import  =  identdef [":" ident].
  1873. *)
  1874. PROCEDURE CompilationUnit * ( source : Files.File);
  1875.  
  1876.   (* CONST pname = "CompilationUnit"; *)
  1877.  
  1878.   VAR
  1879.     L0, retList : INTEGER; ch : CHAR;
  1880.     time, date, key, dsize : LONGINT;
  1881.     impid : ARRAY 32 OF CHAR;
  1882.     FName : ARRAY 256 OF CHAR;
  1883.  
  1884.   (*------------------------------------*)
  1885.   (* $D- disable copying of open arrays *)
  1886.   PROCEDURE MakeFileName (
  1887.     path, module, ext : ARRAY OF CHAR;
  1888.     VAR FName : ARRAY OF CHAR);
  1889.  
  1890.   BEGIN (* MakeFileName *)
  1891.     COPY (path, FName); Str.Append (FName, module); Str.Append (FName, ext)
  1892.   END MakeFileName;
  1893.  
  1894. BEGIN (* CompilationUnit *)
  1895.   (* OCG.TraceIn (mname, pname); *)
  1896.   procNo := 1; dsize := 0; LoopLevel := 0; ExitNo := 0;
  1897.   OCC.Init (); OCT.Init (); OCS.Init (source);
  1898.  
  1899.   REPEAT OCS.Get (sym) UNTIL (sym = eof) OR (sym = module);
  1900.   IF sym # module THEN
  1901.     IO.WriteStr (" !! Err #16: MODULE keyword not found\n");
  1902.     RETURN
  1903.   END;
  1904.  
  1905.   OCS.Get (sym);
  1906.   IF sym = ident THEN
  1907.     L0 := 0; ch := OCS.name [0];
  1908.     WHILE (ch # 0X) & (L0 < ModNameLen) DO
  1909.       OCT.ModuleName [L0] := ch; INC (L0); ch := OCS.name [L0];
  1910.     END;
  1911.     OCT.ModuleName [L0] := 0X;
  1912.     IF ch # 0X THEN OCS.Mark (334) END;
  1913.  
  1914.     OCS.StartModule (OCT.ModuleName); OCT.StartModule ();
  1915.     OCT.OpenScope (0);
  1916.  
  1917.     OCS.Get (sym); CheckSym (semicolon);
  1918.  
  1919.     OCS.allowGlobalSwitches := FALSE;
  1920.     OCH.ModulePrologue ();
  1921.  
  1922.     IF sym = import THEN
  1923.       OCS.Get (sym);
  1924.  
  1925.       LOOP
  1926.         IF sym = ident THEN
  1927.           COPY (OCS.name, impid);
  1928.           OCS.Get (sym);
  1929.           MakeFileName ("", impid, ".Sym", FName);
  1930.  
  1931.           IF sym = becomes THEN
  1932.             OCS.Get (sym);
  1933.             IF sym = ident THEN
  1934.               MakeFileName ("", OCS.name, ".Sym", FName);
  1935.               OCS.Get (sym);
  1936.             ELSE
  1937.               OCS.Mark (10);
  1938.             END;
  1939.           END;
  1940.  
  1941.           OCT.Import (impid, FName);
  1942.         ELSE
  1943.           OCS.Mark (10);
  1944.         END;
  1945.  
  1946.         IF sym = comma THEN     OCS.Get (sym);
  1947.         ELSIF sym = ident THEN  OCS.Mark (19);
  1948.         ELSE                    EXIT;
  1949.         END;
  1950.       END; (* LOOP *)
  1951.  
  1952.       CheckSym (semicolon);
  1953.     END; (* IF *)
  1954.  
  1955.     IF ~OCS.scanerr THEN
  1956.       Block (NIL, dsize, retList);
  1957.       OCH.EndModuleBody (retList);
  1958.  
  1959.       IF sym = ident THEN
  1960.         IF OCS.name # OCT.ModuleName THEN OCS.Mark (4) END;
  1961.         OCS.Get (sym);
  1962.       ELSE
  1963.         OCS.Mark (10);
  1964.       END;
  1965.  
  1966.       IF sym # period THEN OCS.Mark (18) END;
  1967.  
  1968.       IF ~OCS.scanerr OR forceCode THEN
  1969.         IF ~OCS.scanerr THEN
  1970.           Oberon.GetClock (time, date);
  1971.           key := (date MOD 4000H) * 20000H + time;
  1972.           MakeFileName ("", OCT.ModuleName, ".Sym", FName);
  1973.           OCT.Export (FName, newSF, key);
  1974.           IF newSF THEN
  1975.             MakeFileName (OCT.DestPath, OCT.ModuleName, ".Sym", FName);
  1976.             IO.WriteF1 (" >> New symbol file : %s\n", SYS.ADR (FName))
  1977.           END
  1978.         END;
  1979.         IF ~OCS.scanerr OR forceCode THEN
  1980.           MakeFileName (OCT.DestPath, OCT.ModuleName, ".Obj", FName);
  1981.           IO.WriteF1 (" >> Object file : %s\n", SYS.ADR (FName));
  1982.           OCC.OutCode (FName, key, dsize);
  1983.           IO.WriteF3
  1984.             ( "    CODE: %ld, DATA: %ld, VARS: %ld",
  1985.               LONG (OCC.pc), OCC.DataSize (), dsize);
  1986.           IO.WriteF1 (", TOTAL: %ld\n", OCC.pc + dsize + OCC.DataSize ())
  1987.         END;
  1988.       END; (* IF *)
  1989.     END; (* IF *)
  1990.     OCT.CloseScope ();
  1991.     OCT.EndModule (); OCS.EndModule ();
  1992.   ELSE
  1993.     IO.WriteStr (" !! Err #10: identifier expected after MODULE\n")
  1994.   END;
  1995.  
  1996.   IF OCS.scanerr THEN IO.WriteStr (" !! Errors detected\n") END;
  1997.   (* ;OCG.TraceOut (mname, pname); *)
  1998. END CompilationUnit;
  1999.  
  2000.  
  2001. BEGIN (* Compiler *)
  2002.   newSF := FALSE; forceCode := FALSE
  2003. END Compiler.
  2004.  
  2005. (***************************************************************************
  2006.  
  2007.   $Log: Compiler.mod $
  2008.   Revision 4.12.1.1  1994/09/08  18:18:32  fjc
  2009.   - Changed parameters passed to OCC.SaveRegisters() when
  2010.     translating TBP calls, to fix bug in translating TBP calls,.
  2011.     through arrays of objects.
  2012.  
  2013.   Revision 4.12  1994/08/19  20:02:03  fjc
  2014.   - Fixed bug in FormalParameters() which caused an infinite
  2015.     loop if a parameter name was declared twice.
  2016.  
  2017.   Revision 4.10  1994/07/25  00:54:09  fjc
  2018.   - Implemented check for parameter list limit.
  2019.  
  2020.   Revision 4.9  1994/07/24  00:31:02  fjc
  2021.   - Changed to using square brackets in register parameter
  2022.     declarations, in line with Oakwood guidelines.
  2023.  
  2024.   Revision 4.8  1994/07/23  16:07:02  fjc
  2025.   - Changed to allow A5 as a legal register parameter.
  2026.   - Changed to use new formats for OCC.SaveRegisters() and
  2027.     OCH.PrepCall().
  2028.  
  2029.   Revision 4.7  1994/07/22  14:23:06  fjc
  2030.   - Added code to parse foreign procedure declarations.
  2031.   - Changed to use new procedure names in OCH.
  2032.   - Fixed bug in register parameter declarations.
  2033.  
  2034.   Revision 4.6  1994/07/10  13:33:04  fjc
  2035.   - Commented out trace code.
  2036.   - Added check for unimplemented forward declared procedures.
  2037.  
  2038.   Revision 4.5  1994/06/17  17:39:00  fjc
  2039.   - Fixed stackload bug
  2040.  
  2041.   Revision 4.4  1994/06/10  12:50:39  fjc
  2042.   - Changed Factor() to concatenate string literals.
  2043.  
  2044.   Revision 4.3  1994/06/06  18:28:42  fjc
  2045.   - Implemented varargs for LibCall procedures:
  2046.     - Created VarArgs() to push the parameters in reverse order;
  2047.     - Modified ActualParameters() to call VarArgs();
  2048.     - Modified Factor() and StatSeq() to fix up stack afterwards;
  2049.     - Modified FormalParameters() to parse the new syntax.
  2050.  
  2051.   Revision 4.2  1994/06/05  22:31:46  fjc
  2052.   - Changed to conform to new symbol table format.
  2053.   - Added forceCode option.
  2054.  
  2055.   Revision 4.1  1994/06/01  09:33:44  fjc
  2056.   - Bumped version number
  2057.  
  2058. ***************************************************************************)
  2059.  
  2060.